home *** CD-ROM | disk | FTP | other *** search
/ NeXT Education Software Sampler 1992 Fall / NeXT Education Software Sampler 1992 Fall.iso / Programming / Source / winterp-1.13 / examples / xlisp-1.6 / ifthen.lsp < prev    next >
Encoding:
Lisp/Scheme  |  1991-10-06  |  7.9 KB  |  265 lines
  1. ; -*-Lisp-*-
  2. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  3. ;
  4. ; File:         ifthen.lsp
  5. ; RCS:          $Header: $
  6. ; Description:  If then rules - mini expert from Ch. 18 of Winston and Horn
  7. ;        Written using recursion without progs. Added function 'how' to
  8. ;        explain deductions.
  9. ;        Use:
  10. ;           After loading type (deduce). It will make all the deductions
  11. ;           given the list fact. If you want to know how it deduced something
  12. ;           type (how '(a deduction)) for example (how '(animal is tiger))
  13. ;           and so on.
  14. ; Author:       Winston and Horn and ???
  15. ; Created:      Sat Oct  5 20:53:43 1991
  16. ; Modified:     Sat Oct  5 20:55:13 1991 (Niels Mayer) mayer@hplnpm
  17. ; Language:     Lisp
  18. ; Package:      N/A
  19. ; Status:       X11r5 contrib tape release
  20. ;
  21. ; WINTERP Copyright 1989, 1990, 1991 Hewlett-Packard Company (by Niels Mayer).
  22. ; XLISP version 2.1, Copyright (c) 1989, by David Betz.
  23. ;
  24. ; Permission to use, copy, modify, distribute, and sell this software and its
  25. ; documentation for any purpose is hereby granted without fee, provided that
  26. ; the above copyright notice appear in all copies and that both that
  27. ; copyright notice and this permission notice appear in supporting
  28. ; documentation, and that the name of Hewlett-Packard and Niels Mayer not be
  29. ; used in advertising or publicity pertaining to distribution of the software
  30. ; without specific, written prior permission.  Hewlett-Packard and Niels Mayer
  31. ; makes no representations about the suitability of this software for any
  32. ; purpose.  It is provided "as is" without express or implied warranty.
  33. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  34.  
  35. ; rules data base
  36.  
  37. (setq rules
  38.       '((rule identify1
  39.           (if (animal has hair))
  40.           (then (animal is mammal)))
  41.     (rule identify2
  42.           (if (animal gives milk))
  43.           (then (animal is mammal)))
  44.     (rule identify3
  45.           (if (animal has feathers))
  46.           (then (animal is bird)))
  47.     (rule identify4
  48.           (if (animal flies)
  49.           (animal lays eggs))
  50.           (then (animal is bird)))
  51.     (rule identify5
  52.           (if (animal eats meat))
  53.           (then (animal is carnivore)))
  54.     (rule identify6
  55.           (if (animal has pointed teeth)
  56.           (animal has claws)
  57.           (animal has forward eyes))
  58.           (then (animal is carnivore)))
  59.     (rule identify7
  60.           (if (animal is mammal)
  61.           (animal has hoofs))
  62.           (then (animal is ungulate)))
  63.     (rule identify8
  64.           (if (animal is mammal)
  65.           (animal chews cud))
  66.           (then (animal is ungulate)
  67.             (even toed)))
  68.     (rule identify9
  69.           (if (animal is mammal)
  70.           (animal is carnivore)
  71.           (animal has tawny color)
  72.           (animal has dark spots))
  73.           (then (animal is cheetah)))
  74.     (rule identify10
  75.           (if (animal is mammal)
  76.           (animal is carnivore)
  77.           (animal has tawny color)
  78.           (animal has black stripes))
  79.           (then (animal is tiger)))
  80.     (rule identify11
  81.           (if (animal is ungulate)
  82.           (animal has long neck)
  83.           (animal has long legs)
  84.           (animal has dark spots))
  85.           (then (animal is giraffe)))
  86.     (rule identify12
  87.           (if (animal is ungulate)
  88.           (animal has black stripes))
  89.           (then (animal is zebra)))
  90.     (rule identify13
  91.           (if (animal is bird)
  92.           (animal does not fly)
  93.           (animal has long neck)
  94.           (animal has long legs)
  95.           (animal is black and white))
  96.           (then (animal is ostrich)))
  97.     (rule identify14
  98.           (if (animal is bird)
  99.           (animal does not fly)
  100.           (animal swims)
  101.           (animal is black and white))
  102.           (then (animal is penguin)))
  103.     (rule identify15
  104.           (if (animal is bird)
  105.           (animal flys well))
  106.           (then (animal is albatross)))))
  107. ; utility functions
  108. (defun squash(s)
  109.        (cond ((null s) ())
  110.          ((atom s) (list s))
  111.          (t (append (squash (car s))
  112.             (squash (cdr s))))))
  113.  
  114. (defun p(s)
  115.        (princ (squash s)))
  116.  
  117. ; functions
  118.  
  119. ; function to see if an item is a member of a list
  120.  
  121. (defun member(item list)
  122.        (cond((null list) ())    ; return nil on end of list
  123.         ((equal item (car list)) list) ; found
  124.         (t (member item (cdr list))))) ; otherwise try rest of list
  125.  
  126. ; put a new fact into the facts data base if it is not already there
  127.  
  128. (defun remember(newfact)
  129.        (cond((member newfact facts) ())    ; if present do nothing
  130.         (t ( setq facts (cons newfact facts)) newfact)))
  131.  
  132. ; is a fact there in the facts data base
  133.  
  134. (defun recall(afact)
  135.        (cond ((member afact facts) afact)    ; it is here
  136.          (t ())))                ; no it is'nt
  137.  
  138. ; given a rule check if all the if parts are confirmed by the facts data base
  139.  
  140. (defun testif(iflist)
  141.        (cond((null iflist) t)    ; all satisfied
  142.         ((recall (car iflist)) (testif (cdr iflist))) ; keep searching
  143.                                       ; if one is ok
  144.         (t ())))                    ; not in facts DB
  145.  
  146. ; add the then parts of the rules which can be added to the facts DB
  147. ; return the ones that are added
  148.  
  149. (defun usethen(thenlist addlist)
  150.        (cond ((null thenlist) addlist) ; all exhausted
  151.          ((remember (car thenlist))
  152.          (usethen (cdr thenlist) (cons (car thenlist) addlist)))
  153.          (t (usethen (cdr thenlist) addlist))))
  154.  
  155. ; try a rule
  156. ; return t only if all the if parts are satisfied by the facts data base
  157. ; and at lest one then ( conclusion ) is added to the facts data base
  158.  
  159. (defun tryrule(rule &aux ifrules thenlist addlist)
  160.        (setq ifrules (cdr(car(cdr(cdr rule)))))
  161.        (setq thenlist (cdr(car(cdr(cdr(cdr rule))))))
  162.        (setq addlist '())
  163.        (cond (( testif ifrules)
  164.           (cond ((setq addlist (usethen thenlist addlist))
  165.              (p (list "Rule " (car(cdr rule)) "\n\tDeduced " addlist "\n\n"))
  166.              (setq ruleused (cons rule ruleused))
  167.              t)
  168.             (t ())))
  169.          (t ())))
  170.  
  171. ; step through one iteration if the forward search
  172. ; looking for rules that can be deduced from the present fact data base
  173.  
  174. (defun stepforward( rulelist)
  175.        (cond((null rulelist) ())    ; all done
  176.         ((tryrule (car rulelist)) t)
  177.         ( t (stepforward(cdr rulelist)))))
  178.  
  179. ; stepforward until you cannot go any further
  180.  
  181. (defun deduce()
  182.       (cond((stepforward rules) (deduce))
  183.        (t t)))
  184.  
  185. ; function to answer if a fact was used to come to a certain conclusion
  186. ; uses the ruleused list cons'ed by tryrule to answer
  187.  
  188. (defun usedp(rule)
  189.        (cond ((member rule ruleused) t)    ; it has been used
  190.          (t () )))            ; no it hasnt
  191.  
  192. ; function to answer how a fact was deduced
  193.  
  194. (defun how(fact)
  195.        (how2 fact ruleused nil))
  196.  
  197. (defun how2(fact rulist found)
  198.        (cond ((null rulist)    ; if the rule list exhausted
  199.           (cond (found t)   ; already answered the question return t
  200.             ((recall fact) (p (list fact " was a given fact\n")) t) ;known fact
  201.             (t (p (list fact " -- not a fact!\n")) ())))
  202.           
  203.           ((member fact (thenpart (car rulist)))     ; if rulist not empty
  204.            (setq found t)    ; and fact belongs to the then part of a rule
  205.            (p (list fact " was deduced because the following were true\n"))
  206.            (printifs (car rulist))
  207.            (how2 fact (cdr rulist) found))
  208.           (t (how2 fact (cdr rulist) found))))
  209.  
  210. ; function to return the then part of a rule
  211.  
  212. (defun thenpart(rule)
  213.        (cdr(car(cdr(cdr(cdr rule))))))
  214.  
  215. ; function to print the if part of a given rule
  216.  
  217. (defun printifs(rule)
  218.        (pifs (cdr(car(cdr(cdr rule))))))
  219.  
  220. (defun pifs(l)
  221.     (cond ((null l) ())
  222.           (t (p (list "\t" (car l) "\n"))
  223.          (pifs (cdr l)))))
  224.  
  225.  
  226. ; initial facts data base
  227. ; Uncomment one or make up your own
  228. ; Then run 'deduce' to find deductions
  229. ; Run 'how' to find out how it came to a certain deduction
  230.  
  231. ;(setq facts
  232. ;      '((animal has dark spots)
  233. ;    (animal has tawny color)
  234. ;    (animal eats meat)
  235. ;    (animal has hair)))
  236.  
  237. (setq facts
  238.       '((animal has hair)
  239.     (animal has pointed teeth)
  240.     (animal has black stripes)
  241.     (animal has claws)
  242.     (animal has forward eyes)
  243.     (animal has tawny color)))
  244.  
  245.  
  246. (setq rl1
  247.           '(rule identify14
  248.           (if (animal is bird)
  249.           (animal does not fly)
  250.           (animal swims)
  251.           (animal is black and white))
  252.           (then (animal is penguin))))
  253.  
  254. (setq rl2
  255.         '(rule identify10
  256.           (if (animal is mammal)
  257.           (animal is carnivore)
  258.           (animal has tawny color)
  259.           (animal has black stripes))
  260.           (then (animal is tiger))))
  261.  
  262. ; Initialization
  263. (expand 10)
  264. (setq ruleused nil)
  265.